home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / ExtUtils / Constant / Base.pm next >
Encoding:
Perl POD Document  |  2009-06-26  |  32.2 KB  |  1,007 lines
  1. package ExtUtils::Constant::Base;
  2.  
  3. use strict;
  4. use vars qw($VERSION);
  5. use Carp;
  6. use Text::Wrap;
  7. use ExtUtils::Constant::Utils qw(C_stringify perl_stringify);
  8. $VERSION = '0.04';
  9.  
  10. use constant is_perl56 => ($] < 5.007 && $] > 5.005_50);
  11.  
  12.  
  13. =head1 NAME
  14.  
  15. ExtUtils::Constant::Base - base class for ExtUtils::Constant objects
  16.  
  17. =head1 SYNOPSIS
  18.  
  19.     require ExtUtils::Constant::Base;
  20.     @ISA = 'ExtUtils::Constant::Base';
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. ExtUtils::Constant::Base provides a base implementation of methods to
  25. generate C code to give fast constant value lookup by named string. Currently
  26. it's mostly used ExtUtils::Constant::XS, which generates the lookup code
  27. for the constant() subroutine found in many XS modules.
  28.  
  29. =head1 USAGE
  30.  
  31. ExtUtils::Constant::Base exports no subroutines. The following methods are
  32. available
  33.  
  34. =over 4
  35.  
  36. =cut
  37.  
  38. sub valid_type {
  39.   # Default to assuming that you don't need different types of return data.
  40.   1;
  41. }
  42. sub default_type {
  43.   '';
  44. }
  45.  
  46. =item header
  47.  
  48. A method returning a scalar containing definitions needed, typically for a
  49. C header file.
  50.  
  51. =cut
  52.  
  53. sub header {
  54.   ''
  55. }
  56.  
  57. # This might actually be a return statement. Note that you are responsible
  58. # for any space you might need before your value, as it lets to perform
  59. # "tricks" such as "return KEY_" and have strings appended.
  60. sub assignment_clause_for_type;
  61. # In which case this might be an empty string
  62. sub return_statement_for_type {undef};
  63. sub return_statement_for_notdef;
  64. sub return_statement_for_notfound;
  65.  
  66. # "#if 1" is true to a C pre-processor
  67. sub macro_from_name {
  68.   1;
  69. }
  70.  
  71. sub macro_from_item {
  72.   1;
  73. }
  74.  
  75. sub macro_to_ifdef {
  76.     my ($self, $macro) = @_;
  77.     if (ref $macro) {
  78.     return $macro->[0];
  79.     }
  80.     if (defined $macro && $macro ne "" && $macro ne "1") {
  81.     return $macro ? "#ifdef $macro\n" : "#if 0\n";
  82.     }
  83.     return "";
  84. }
  85.  
  86. sub macro_to_endif {
  87.     my ($self, $macro) = @_;
  88.  
  89.     if (ref $macro) {
  90.     return $macro->[1];
  91.     }
  92.     if (defined $macro && $macro ne "" && $macro ne "1") {
  93.     return "#endif\n";
  94.     }
  95.     return "";
  96. }
  97.  
  98. sub name_param {
  99.   'name';
  100. }
  101.  
  102. # This is possibly buggy, in that it's not mandatory (below, in the main
  103. # C_constant parameters, but is expected to exist here, if it's needed)
  104. # Buggy because if you're definitely pure 8 bit only, and will never be
  105. # presented with your constants in utf8, the default form of C_constant can't
  106. # be told not to do the utf8 version.
  107.  
  108. sub is_utf8_param {
  109.   'utf8';
  110. }
  111.  
  112. sub memEQ {
  113.   "!memcmp";
  114. }
  115.  
  116. =item memEQ_clause args_hashref
  117.  
  118. A method to return a suitable C C<if> statement to check whether I<name>
  119. is equal to the C variable C<name>. If I<checked_at> is defined, then it
  120. is used to avoid C<memEQ> for short names, or to generate a comment to
  121. highlight the position of the character in the C<switch> statement.
  122.  
  123. If i<checked_at> is a reference to a scalar, then instead it gives
  124. the characters pre-checked at the beginning, (and the number of chars by
  125. which the C variable name has been advanced. These need to be chopped from
  126. the front of I<name>).
  127.  
  128. =cut
  129.  
  130. sub memEQ_clause {
  131. #    if (memEQ(name, "thingy", 6)) {
  132.   # Which could actually be a character comparison or even ""
  133.   my ($self, $args) = @_;
  134.   my ($name, $checked_at, $indent) = @{$args}{qw(name checked_at indent)};
  135.   $indent = ' ' x ($indent || 4);
  136.   my $front_chop;
  137.   if (ref $checked_at) {
  138.     # regexp won't work on 5.6.1 without use utf8; in turn that won't work
  139.     # on 5.005_03.
  140.     substr ($name, 0, length $$checked_at,) = '';
  141.     $front_chop = C_stringify ($$checked_at);
  142.     undef $checked_at;
  143.   }
  144.   my $len = length $name;
  145.  
  146.   if ($len < 2) {
  147.     return $indent . "{\n"
  148.     if (defined $checked_at and $checked_at == 0) or $len == 0;
  149.     # We didn't switch, drop through to the code for the 2 character string
  150.     $checked_at = 1;
  151.   }
  152.  
  153.   my $name_param = $self->name_param;
  154.  
  155.   if ($len < 3 and defined $checked_at) {
  156.     my $check;
  157.     if ($checked_at == 1) {
  158.       $check = 0;
  159.     } elsif ($checked_at == 0) {
  160.       $check = 1;
  161.     }
  162.     if (defined $check) {
  163.       my $char = C_stringify (substr $name, $check, 1);
  164.       # Placate 5.005 with a break in the string. I can't see a good way of
  165.       # getting it to not take [ as introducing an array lookup, even with
  166.       # ${name_param}[$check]
  167.       return $indent . "if ($name_param" . "[$check] == '$char') {\n";
  168.     }
  169.   }
  170.   if (($len == 2 and !defined $checked_at)
  171.      or ($len == 3 and defined ($checked_at) and $checked_at == 2)) {
  172.     my $char1 = C_stringify (substr $name, 0, 1);
  173.     my $char2 = C_stringify (substr $name, 1, 1);
  174.     return $indent .
  175.       "if ($name_param" . "[0] == '$char1' && $name_param" . "[1] == '$char2') {\n";
  176.   }
  177.   if (($len == 3 and defined ($checked_at) and $checked_at == 1)) {
  178.     my $char1 = C_stringify (substr $name, 0, 1);
  179.     my $char2 = C_stringify (substr $name, 2, 1);
  180.     return $indent .
  181.       "if ($name_param" . "[0] == '$char1' && $name_param" . "[2] == '$char2') {\n";
  182.   }
  183.  
  184.   my $pointer = '^';
  185.   my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1;
  186.   if ($have_checked_last) {
  187.     # Checked at the last character, so no need to memEQ it.
  188.     $pointer = C_stringify (chop $name);
  189.     $len--;
  190.   }
  191.  
  192.   $name = C_stringify ($name);
  193.   my $memEQ = $self->memEQ();
  194.   my $body = $indent . "if ($memEQ($name_param, \"$name\", $len)) {\n";
  195.   # Put a little ^ under the letter we checked at
  196.   # Screws up for non printable and non-7 bit stuff, but that's too hard to
  197.   # get right.
  198.   if (defined $checked_at) {
  199.     $body .= $indent . "/*      " . (' ' x length $memEQ)
  200.       . (' ' x length $name_param)
  201.       . (' ' x $checked_at) . $pointer
  202.       . (' ' x ($len - $checked_at + length $len)) . "    */\n";
  203.   } elsif (defined $front_chop) {
  204.     $body .= $indent . "/*                $front_chop"
  205.       . (' ' x ($len + 1 + length $len)) . "    */\n";
  206.   }
  207.   return $body;
  208. }
  209.  
  210. =item dump_names arg_hashref, ITEM...
  211.  
  212. An internal function to generate the embedded perl code that will regenerate
  213. the constant subroutines.  I<default_type>, I<types> and I<ITEM>s are the
  214. same as for C_constant.  I<indent> is treated as number of spaces to indent
  215. by.  If C<declare_types> is true a C<$types> is always declared in the perl
  216. code generated, if defined and false never declared, and if undefined C<$types>
  217. is only declared if the values in I<types> as passed in cannot be inferred from
  218. I<default_types> and the I<ITEM>s.
  219.  
  220. =cut
  221.  
  222. sub dump_names {
  223.   my ($self, $args, @items) = @_;
  224.   my ($default_type, $what, $indent, $declare_types)
  225.     = @{$args}{qw(default_type what indent declare_types)};
  226.   $indent = ' ' x ($indent || 0);
  227.  
  228.   my $result;
  229.   my (@simple, @complex, %used_types);
  230.   foreach (@items) {
  231.     my $type;
  232.     if (ref $_) {
  233.       $type = $_->{type} || $default_type;
  234.       if ($_->{utf8}) {
  235.         # For simplicity always skip the bytes case, and reconstitute this entry
  236.         # from its utf8 twin.
  237.         next if $_->{utf8} eq 'no';
  238.         # Copy the hashref, as we don't want to mess with the caller's hashref.
  239.         $_ = {%$_};
  240.         unless (is_perl56) {
  241.           utf8::decode ($_->{name});
  242.         } else {
  243.           $_->{name} = pack 'U*', unpack 'U0U*', $_->{name};
  244.         }
  245.         delete $_->{utf8};
  246.       }
  247.     } else {
  248.       $_ = {name=>$_};
  249.       $type = $default_type;
  250.     }
  251.     $used_types{$type}++;
  252.     if ($type eq $default_type
  253.         # grr 5.6.1
  254.         and length $_->{name}
  255.         and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//)
  256.         and !defined ($_->{macro}) and !defined ($_->{value})
  257.         and !defined ($_->{default}) and !defined ($_->{pre})
  258.         and !defined ($_->{post}) and !defined ($_->{def_pre})
  259.         and !defined ($_->{def_post}) and !defined ($_->{weight})) {
  260.       # It's the default type, and the name consists only of A-Za-z0-9_
  261.       push @simple, $_->{name};
  262.     } else {
  263.       push @complex, $_;
  264.     }
  265.   }
  266.  
  267.   if (!defined $declare_types) {
  268.     # Do they pass in any types we weren't already using?
  269.     foreach (keys %$what) {
  270.       next if $used_types{$_};
  271.       $declare_types++; # Found one in $what that wasn't used.
  272.       last; # And one is enough to terminate this loop
  273.     }
  274.   }
  275.   if ($declare_types) {
  276.     $result = $indent . 'my $types = {map {($_, 1)} qw('
  277.       . join (" ", sort keys %$what) . ")};\n";
  278.   }
  279.   local $Text::Wrap::huge = 'overflow';
  280.   local $Text::Wrap::columns = 80;
  281.   $result .= wrap ($indent . "my \@names = (qw(",
  282.            $indent . "               ", join (" ", sort @simple) . ")");
  283.   if (@complex) {
  284.     foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
  285.       my $name = perl_stringify $item->{name};
  286.       my $line = ",\n$indent            {name=>\"$name\"";
  287.       $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
  288.       foreach my $thing (qw (macro value default pre post def_pre def_post)) {
  289.         my $value = $item->{$thing};
  290.         if (defined $value) {
  291.           if (ref $value) {
  292.             $line .= ", $thing=>[\""
  293.               . join ('", "', map {perl_stringify $_} @$value) . '"]';
  294.           } else {
  295.             $line .= ", $thing=>\"" . perl_stringify($value) . "\"";
  296.           }
  297.         }
  298.       }
  299.       $line .= "}";
  300.       # Ensure that the enclosing C comment doesn't end
  301.       # by turning */  into *" . "/
  302.       $line =~ s!\*\/!\*" . "/!gs;
  303.       # gcc -Wall doesn't like finding /* inside a comment
  304.       $line =~ s!\/\*!/" . "\*!gs;
  305.       $result .= $line;
  306.     }
  307.   }
  308.   $result .= ");\n";
  309.  
  310.   $result;
  311. }
  312.  
  313. =item assign arg_hashref, VALUE...
  314.  
  315. A method to return a suitable assignment clause. If I<type> is aggregate
  316. (eg I<PVN> expects both pointer and length) then there should be multiple
  317. I<VALUE>s for the components. I<pre> and I<post> if defined give snippets
  318. of C code to proceed and follow the assignment. I<pre> will be at the start
  319. of a block, so variables may be defined in it.
  320.  
  321. =cut
  322. # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
  323.  
  324. sub assign {
  325.   my $self = shift;
  326.   my $args = shift;
  327.   my ($indent, $type, $pre, $post, $item)
  328.       = @{$args}{qw(indent type pre post item)};
  329.   $post ||= '';
  330.   my $clause;
  331.   my $close;
  332.   if ($pre) {
  333.     chomp $pre;
  334.     $close = "$indent}\n";
  335.     $clause = $indent . "{\n";
  336.     $indent .= "  ";
  337.     $clause .= "$indent$pre";
  338.     $clause .= ";" unless $pre =~ /;$/;
  339.     $clause .= "\n";
  340.   }
  341.   confess "undef \$type" unless defined $type;
  342.   confess "Can't generate code for type $type"
  343.     unless $self->valid_type($type);
  344.  
  345.   $clause .= join '', map {"$indent$_\n"}
  346.     $self->assignment_clause_for_type({type=>$type,item=>$item}, @_);
  347.   chomp $post;
  348.   if (length $post) {
  349.     $clause .= "$post";
  350.     $clause .= ";" unless $post =~ /;$/;
  351.     $clause .= "\n";
  352.   }
  353.   my $return = $self->return_statement_for_type($type);
  354.   $clause .= "$indent$return\n" if defined $return;
  355.   $clause .= $close if $close;
  356.   return $clause;
  357. }
  358.  
  359. =item return_clause arg_hashref, ITEM
  360.  
  361. A method to return a suitable C<#ifdef> clause. I<ITEM> is a hashref
  362. (as passed to C<C_constant> and C<match_clause>. I<indent> is the number
  363. of spaces to indent, defaulting to 6.
  364.  
  365. =cut
  366.  
  367. sub return_clause {
  368.  
  369. ##ifdef thingy
  370. #      *iv_return = thingy;
  371. #      return PERL_constant_ISIV;
  372. ##else
  373. #      return PERL_constant_NOTDEF;
  374. ##endif
  375.   my ($self, $args, $item) = @_;
  376.   my $indent = $args->{indent};
  377.  
  378.   my ($name, $value, $default, $pre, $post, $def_pre, $def_post, $type)
  379.     = @$item{qw (name value default pre post def_pre def_post type)};
  380.   $value = $name unless defined $value;
  381.   my $macro = $self->macro_from_item($item);
  382.   $indent = ' ' x ($indent || 6);
  383.   unless (defined $type) {
  384.     # use Data::Dumper; print STDERR Dumper ($item);
  385.     confess "undef \$type";
  386.   }
  387.  
  388.   ##ifdef thingy
  389.   my $clause = $self->macro_to_ifdef($macro);
  390.  
  391.   #      *iv_return = thingy;
  392.   #      return PERL_constant_ISIV;
  393.   $clause
  394.     .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, post=>$post,
  395.                item=>$item}, ref $value ? @$value : $value);
  396.  
  397.   if (defined $macro && $macro ne "" && $macro ne "1") {
  398.     ##else
  399.     $clause .= "#else\n";
  400.  
  401.     #      return PERL_constant_NOTDEF;
  402.     if (!defined $default) {
  403.       my $notdef = $self->return_statement_for_notdef();
  404.       $clause .= "$indent$notdef\n" if defined $notdef;
  405.     } else {
  406.       my @default = ref $default ? @$default : $default;
  407.       $type = shift @default;
  408.       $clause .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre,
  409.                  post=>$post, item=>$item}, @default);
  410.     }
  411.   }
  412.   ##endif
  413.   $clause .= $self->macro_to_endif($macro);
  414.  
  415.   return $clause;
  416. }
  417.  
  418. sub match_clause {
  419.   # $offset defined if we have checked an offset.
  420.   my ($self, $args, $item) = @_;
  421.   my ($offset, $indent) = @{$args}{qw(checked_at indent)};
  422.   $indent = ' ' x ($indent || 4);
  423.   my $body = '';
  424.   my ($no, $yes, $either, $name, $inner_indent);
  425.   if (ref $item eq 'ARRAY') {
  426.     ($yes, $no) = @$item;
  427.     $either = $yes || $no;
  428.     confess "$item is $either expecting hashref in [0] || [1]"
  429.       unless ref $either eq 'HASH';
  430.     $name = $either->{name};
  431.   } else {
  432.     confess "$item->{name} has utf8 flag '$item->{utf8}', should be false"
  433.       if $item->{utf8};
  434.     $name = $item->{name};
  435.     $inner_indent = $indent;
  436.   }
  437.  
  438.   $body .= $self->memEQ_clause ({name => $name, checked_at => $offset,
  439.                  indent => length $indent});
  440.   # If we've been presented with an arrayref for $item, then the user string
  441.   # contains in the range 128-255, and we need to check whether it was utf8
  442.   # (or not).
  443.   # In the worst case we have two named constants, where one's name happens
  444.   # encoded in UTF8 happens to be the same byte sequence as the second's
  445.   # encoded in (say) ISO-8859-1.
  446.   # In this case, $yes and $no both have item hashrefs.
  447.   if ($yes) {
  448.     $body .= $indent . "  if (" . $self->is_utf8_param . ") {\n";
  449.   } elsif ($no) {
  450.     $body .= $indent . "  if (!" . $self->is_utf8_param . ") {\n";
  451.   }
  452.   if ($either) {
  453.     $body .= $self->return_clause ({indent=>4 + length $indent}, $either);
  454.     if ($yes and $no) {
  455.       $body .= $indent . "  } else {\n";
  456.       $body .= $self->return_clause ({indent=>4 + length $indent}, $no);
  457.     }
  458.     $body .= $indent . "  }\n";
  459.   } else {
  460.     $body .= $self->return_clause ({indent=>2 + length $indent}, $item);
  461.   }
  462.   $body .= $indent . "}\n";
  463. }
  464.  
  465.  
  466. =item switch_clause arg_hashref, NAMELEN, ITEMHASH, ITEM...
  467.  
  468. An internal method to generate a suitable C<switch> clause, called by
  469. C<C_constant> I<ITEM>s are in the hash ref format as given in the description
  470. of C<C_constant>, and must all have the names of the same length, given by
  471. I<NAMELEN>.  I<ITEMHASH> is a reference to a hash, keyed by name, values being
  472. the hashrefs in the I<ITEM> list.  (No parameters are modified, and there can
  473. be keys in the I<ITEMHASH> that are not in the list of I<ITEM>s without
  474. causing problems - the hash is passed in to save generating it afresh for
  475. each call).
  476.  
  477. =cut
  478.  
  479. sub switch_clause {
  480.   my ($self, $args, $namelen, $items, @items) = @_;
  481.   my ($indent, $comment) = @{$args}{qw(indent comment)};
  482.   $indent = ' ' x ($indent || 2);
  483.  
  484.   local $Text::Wrap::huge = 'overflow';
  485.   local $Text::Wrap::columns = 80;
  486.  
  487.   my @names = sort map {$_->{name}} @items;
  488.   my $leader = $indent . '/* ';
  489.   my $follower = ' ' x length $leader;
  490.   my $body = $indent . "/* Names all of length $namelen.  */\n";
  491.   if (defined $comment) {
  492.     $body = wrap ($leader, $follower, $comment) . "\n";
  493.     $leader = $follower;
  494.   }
  495.   my @safe_names = @names;
  496.   foreach (@safe_names) {
  497.     confess sprintf "Name '$_' is length %d, not $namelen", length
  498.       unless length == $namelen;
  499.     # Argh. 5.6.1
  500.     # next unless tr/A-Za-z0-9_//c;
  501.     next if tr/A-Za-z0-9_// == length;
  502.     $_ = '"' . perl_stringify ($_) . '"';
  503.     # Ensure that the enclosing C comment doesn't end
  504.     # by turning */  into *" . "/
  505.     s!\*\/!\*"."/!gs;
  506.     # gcc -Wall doesn't like finding /* inside a comment
  507.     s!\/\*!/"."\*!gs;
  508.   }
  509.   $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n";
  510.   # Figure out what to switch on.
  511.   # (RMS, Spread of jump table, Position, Hashref)
  512.   my @best = (1e38, ~0);
  513.   # Prefer the last character over the others. (As it lets us shorten the
  514.   # memEQ clause at no cost).
  515.   foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) {
  516.     my ($min, $max) = (~0, 0);
  517.     my %spread;
  518.     if (is_perl56) {
  519.       # Need proper Unicode preserving hash keys for bytes in range 128-255
  520.       # here too, for some reason. grr 5.6.1 yet again.
  521.       tie %spread, 'ExtUtils::Constant::Aaargh56Hash';
  522.     }
  523.     foreach (@names) {
  524.       my $char = substr $_, $i, 1;
  525.       my $ord = ord $char;
  526.       confess "char $ord is out of range" if $ord > 255;
  527.       $max = $ord if $ord > $max;
  528.       $min = $ord if $ord < $min;
  529.       push @{$spread{$char}}, $_;
  530.       # warn "$_ $char";
  531.     }
  532.     # I'm going to pick the character to split on that minimises the root
  533.     # mean square of the number of names in each case. Normally this should
  534.     # be the one with the most keys, but it may pick a 7 where the 8 has
  535.     # one long linear search. I'm not sure if RMS or just sum of squares is
  536.     # actually better.
  537.     # $max and $min are for the tie-breaker if the root mean squares match.
  538.     # Assuming that the compiler may be building a jump table for the
  539.     # switch() then try to minimise the size of that jump table.
  540.     # Finally use < not <= so that if it still ties the earliest part of
  541.     # the string wins. Because if that passes but the memEQ fails, it may
  542.     # only need the start of the string to bin the choice.
  543.     # I think. But I'm micro-optimising. :-)
  544.     # OK. Trump that. Now favour the last character of the string, before the
  545.     # rest.
  546.     my $ss;
  547.     $ss += @$_ * @$_ foreach values %spread;
  548.     my $rms = sqrt ($ss / keys %spread);
  549.     if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
  550.       @best = ($rms, $max - $min, $i, \%spread);
  551.     }
  552.   }
  553.   confess "Internal error. Failed to pick a switch point for @names"
  554.     unless defined $best[2];
  555.   # use Data::Dumper; print Dumper (@best);
  556.   my ($offset, $best) = @best[2,3];
  557.   $body .= $indent . "/* Offset $offset gives the best switch position.  */\n";
  558.  
  559.   my $do_front_chop = $offset == 0 && $namelen > 2;
  560.   if ($do_front_chop) {
  561.     $body .= $indent . "switch (*" . $self->name_param() . "++) {\n";
  562.   } else {
  563.     $body .= $indent . "switch (" . $self->name_param() . "[$offset]) {\n";
  564.   }
  565.   foreach my $char (sort keys %$best) {
  566.     confess sprintf "'$char' is %d bytes long, not 1", length $char
  567.       if length ($char) != 1;
  568.     confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255;
  569.     $body .= $indent . "case '" . C_stringify ($char) . "':\n";
  570.     foreach my $thisone (sort {
  571.     # Deal with the case of an item actually being an array ref to 1 or 2
  572.     # hashrefs. Don't assign to $a or $b, as they're aliases to the orignal
  573.     my $l = ref $a eq 'ARRAY' ? ($a->[0] || $->[1]) : $a;
  574.     my $r = ref $b eq 'ARRAY' ? ($b->[0] || $->[1]) : $b;
  575.     # Sort by weight first
  576.     ($r->{weight} || 0) <=> ($l->{weight} || 0)
  577.         # Sort equal weights by name
  578.         or $l->{name} cmp $r->{name}}
  579.              # If this looks evil, maybe it is.  $items is a
  580.              # hashref, and we're doing a hash slice on it
  581.              @{$items}{@{$best->{$char}}}) {
  582.       # warn "You are here";
  583.       if ($do_front_chop) {
  584.         $body .= $self->match_clause ({indent => 2 + length $indent,
  585.                        checked_at => \$char}, $thisone);
  586.       } else {
  587.         $body .= $self->match_clause ({indent => 2 + length $indent,
  588.                        checked_at => $offset}, $thisone);
  589.       }
  590.     }
  591.     $body .= $indent . "  break;\n";
  592.   }
  593.   $body .= $indent . "}\n";
  594.   return $body;
  595. }
  596.  
  597. sub C_constant_return_type {
  598.   "static int";
  599. }
  600.  
  601. sub C_constant_prefix_param {
  602.   '';
  603. }
  604.  
  605. sub C_constant_prefix_param_defintion {
  606.   '';
  607. }
  608.  
  609. sub name_param_definition {
  610.   "const char *" . $_[0]->name_param;
  611. }
  612.  
  613. sub namelen_param {
  614.   'len';
  615. }
  616.  
  617. sub namelen_param_definition {
  618.   'size_t ' . $_[0]->namelen_param;
  619. }
  620.  
  621. sub C_constant_other_params {
  622.   '';
  623. }
  624.  
  625. sub C_constant_other_params_defintion {
  626.   '';
  627. }
  628.  
  629. =item params WHAT
  630.  
  631. An "internal" method, subject to change, currently called to allow an
  632. overriding class to cache information that will then be passed into all
  633. the C<*param*> calls. (Yes, having to read the source to make sense of this is
  634. considered a known bug). I<WHAT> is be a hashref of types the constant
  635. function will return. In ExtUtils::Constant::XS this method is used to
  636. returns a hashref keyed IV NV PV SV to show which combination of pointers will
  637. be needed in the C argument list generated by
  638. C_constant_other_params_definition and C_constant_other_params
  639.  
  640. =cut
  641.  
  642. sub params {
  643.   '';
  644. }
  645.  
  646.  
  647. =item dogfood arg_hashref, ITEM...
  648.  
  649. An internal function to generate the embedded perl code that will regenerate
  650. the constant subroutines.  Parameters are the same as for C_constant.
  651.  
  652. Currently the base class does nothing and returns an empty string.
  653.  
  654. =cut
  655.  
  656. sub dogfood {
  657.   ''
  658. }
  659.  
  660. =item normalise_items args, default_type, seen_types, seen_items, ITEM...
  661.  
  662. Convert the items to a normalised form. For 8 bit and Unicode values converts
  663. the item to an array of 1 or 2 items, both 8 bit and UTF-8 encoded.
  664.  
  665. =cut
  666.  
  667. sub normalise_items
  668. {
  669.     my $self = shift;
  670.     my $args = shift;
  671.     my $default_type = shift;
  672.     my $what = shift;
  673.     my $items = shift;
  674.     my @new_items;
  675.     foreach my $orig (@_) {
  676.     my ($name, $item);
  677.       if (ref $orig) {
  678.         # Make a copy which is a normalised version of the ref passed in.
  679.         $name = $orig->{name};
  680.         my ($type, $macro, $value) = @$orig{qw (type macro value)};
  681.         $type ||= $default_type;
  682.         $what->{$type} = 1;
  683.         $item = {name=>$name, type=>$type};
  684.  
  685.         undef $macro if defined $macro and $macro eq $name;
  686.         $item->{macro} = $macro if defined $macro;
  687.         undef $value if defined $value and $value eq $name;
  688.         $item->{value} = $value if defined $value;
  689.         foreach my $key (qw(default pre post def_pre def_post weight
  690.                 not_constant)) {
  691.           my $value = $orig->{$key};
  692.           $item->{$key} = $value if defined $value;
  693.           # warn "$key $value";
  694.         }
  695.       } else {
  696.         $name = $orig;
  697.         $item = {name=>$name, type=>$default_type};
  698.         $what->{$default_type} = 1;
  699.       }
  700.       warn +(ref ($self) || $self)
  701.     . "doesn't know how to handle values of type $_ used in macro $name"
  702.       unless $self->valid_type ($item->{type});
  703.       # tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c
  704.       # doesn't work. Upgrade to 5.8
  705.       # if ($name !~ tr/\0-\177//c || $] < 5.005_50) {
  706.       if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50
  707.      || $args->{disable_utf8_duplication}) {
  708.         # No characters outside 7 bit ASCII.
  709.         if (exists $items->{$name}) {
  710.           die "Multiple definitions for macro $name";
  711.         }
  712.         $items->{$name} = $item;
  713.       } else {
  714.         # No characters outside 8 bit. This is hardest.
  715.         if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') {
  716.           confess "Unexpected ASCII definition for macro $name";
  717.         }
  718.         # Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/;
  719.         # if ($name !~ tr/\0-\377//c) {
  720.         if ($name =~ tr/\0-\377// == length $name) {
  721. #          if ($] < 5.007) {
  722. #            $name = pack "C*", unpack "U*", $name;
  723. #          }
  724.           $item->{utf8} = 'no';
  725.           $items->{$name}[1] = $item;
  726.           push @new_items, $item;
  727.           # Copy item, to create the utf8 variant.
  728.           $item = {%$item};
  729.         }
  730.         # Encode the name as utf8 bytes.
  731.         unless (is_perl56) {
  732.           utf8::encode($name);
  733.         } else {
  734. #          warn "Was >$name< " . length ${name};
  735.           $name = pack 'C*', unpack 'C*', $name . pack 'U*';
  736. #          warn "Now '${name}' " . length ${name};
  737.         }
  738.         if ($items->{$name}[0]) {
  739.           die "Multiple definitions for macro $name";
  740.         }
  741.         $item->{utf8} = 'yes';
  742.         $item->{name} = $name;
  743.         $items->{$name}[0] = $item;
  744.         # We have need for the utf8 flag.
  745.         $what->{''} = 1;
  746.       }
  747.       push @new_items, $item;
  748.     }
  749.     @new_items;
  750. }
  751.  
  752. =item C_constant arg_hashref, ITEM...
  753.  
  754. A function that returns a B<list> of C subroutine definitions that return
  755. the value and type of constants when passed the name by the XS wrapper.
  756. I<ITEM...> gives a list of constant names. Each can either be a string,
  757. which is taken as a C macro name, or a reference to a hash with the following
  758. keys
  759.  
  760. =over 8
  761.  
  762. =item name
  763.  
  764. The name of the constant, as seen by the perl code.
  765.  
  766. =item type
  767.  
  768. The type of the constant (I<IV>, I<NV> etc)
  769.  
  770. =item value
  771.  
  772. A C expression for the value of the constant, or a list of C expressions if
  773. the type is aggregate. This defaults to the I<name> if not given.
  774.  
  775. =item macro
  776.  
  777. The C pre-processor macro to use in the C<#ifdef>. This defaults to the
  778. I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
  779. array is passed then the first element is used in place of the C<#ifdef>
  780. line, and the second element in place of the C<#endif>. This allows
  781. pre-processor constructions such as
  782.  
  783.     #if defined (foo)
  784.     #if !defined (bar)
  785.     ...
  786.     #endif
  787.     #endif
  788.  
  789. to be used to determine if a constant is to be defined.
  790.  
  791. A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
  792. test is omitted.
  793.  
  794. =item default
  795.  
  796. Default value to use (instead of C<croak>ing with "your vendor has not
  797. defined...") to return if the macro isn't defined. Specify a reference to
  798. an array with type followed by value(s).
  799.  
  800. =item pre
  801.  
  802. C code to use before the assignment of the value of the constant. This allows
  803. you to use temporary variables to extract a value from part of a C<struct>
  804. and return this as I<value>. This C code is places at the start of a block,
  805. so you can declare variables in it.
  806.  
  807. =item post
  808.  
  809. C code to place between the assignment of value (to a temporary) and the
  810. return from the function. This allows you to clear up anything in I<pre>.
  811. Rarely needed.
  812.  
  813. =item def_pre
  814.  
  815. =item def_post
  816.  
  817. Equivalents of I<pre> and I<post> for the default value.
  818.  
  819. =item utf8
  820.  
  821. Generated internally. Is zero or undefined if name is 7 bit ASCII,
  822. "no" if the name is 8 bit (and so should only match if SvUTF8() is false),
  823. "yes" if the name is utf8 encoded.
  824.  
  825. The internals automatically clone any name with characters 128-255 but none
  826. 256+ (ie one that could be either in bytes or utf8) into a second entry
  827. which is utf8 encoded.
  828.  
  829. =item weight
  830.  
  831. Optional sorting weight for names, to determine the order of
  832. linear testing when multiple names fall in the same case of a switch clause.
  833. Higher comes earlier, undefined defaults to zero.
  834.  
  835. =back
  836.  
  837. In the argument hashref, I<package> is the name of the package, and is only
  838. used in comments inside the generated C code. I<subname> defaults to
  839. C<constant> if undefined.
  840.  
  841. I<default_type> is the type returned by C<ITEM>s that don't specify their
  842. type. It defaults to the value of C<default_type()>. I<types> should be given
  843. either as a comma separated list of types that the C subroutine I<subname>
  844. will generate or as a reference to a hash. I<default_type> will be added to
  845. the list if not present, as will any types given in the list of I<ITEM>s. The
  846. resultant list should be the same list of types that C<XS_constant> is
  847. given. [Otherwise C<XS_constant> and C<C_constant> may differ in the number of
  848. parameters to the constant function. I<indent> is currently unused and
  849. ignored. In future it may be used to pass in information used to change the C
  850. indentation style used.]  The best way to maintain consistency is to pass in a
  851. hash reference and let this function update it.
  852.  
  853. I<breakout> governs when child functions of I<subname> are generated.  If there
  854. are I<breakout> or more I<ITEM>s with the same length of name, then the code
  855. to switch between them is placed into a function named I<subname>_I<len>, for
  856. example C<constant_5> for names 5 characters long.  The default I<breakout> is
  857. 3.  A single C<ITEM> is always inlined.
  858.  
  859. =cut
  860.  
  861. # The parameter now BREAKOUT was previously documented as:
  862. #
  863. # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
  864. # this length, and that the constant name passed in by perl is checked and
  865. # also of this length. It is used during recursion, and should be C<undef>
  866. # unless the caller has checked all the lengths during code generation, and
  867. # the generated subroutine is only to be called with a name of this length.
  868. #
  869. # As you can see it now performs this function during recursion by being a
  870. # scalar reference.
  871.  
  872. sub C_constant {
  873.   my ($self, $args, @items) = @_;
  874.   my ($package, $subname, $default_type, $what, $indent, $breakout) =
  875.     @{$args}{qw(package subname default_type types indent breakout)};
  876.   $package ||= 'Foo';
  877.   $subname ||= 'constant';
  878.   # I'm not using this. But a hashref could be used for full formatting without
  879.   # breaking this API
  880.   # $indent ||= 0;
  881.  
  882.   my ($namelen, $items);
  883.   if (ref $breakout) {
  884.     # We are called recursively. We trust @items to be normalised, $what to
  885.     # be a hashref, and pinch %$items from our parent to save recalculation.
  886.     ($namelen, $items) = @$breakout;
  887.   } else {
  888.     $items = {};
  889.     if (is_perl56) {
  890.       # Need proper Unicode preserving hash keys.
  891.       require ExtUtils::Constant::Aaargh56Hash;
  892.       tie %$items, 'ExtUtils::Constant::Aaargh56Hash';
  893.     }
  894.     $breakout ||= 3;
  895.     $default_type ||= $self->default_type();
  896.     if (!ref $what) {
  897.       # Convert line of the form IV,UV,NV to hash
  898.       $what = {map {$_ => 1} split /,\s*/, ($what || '')};
  899.       # Figure out what types we're dealing with, and assign all unknowns to the
  900.       # default type
  901.     }
  902.     @items = $self->normalise_items ({}, $default_type, $what, $items, @items);
  903.     # use Data::Dumper; print Dumper @items;
  904.   }
  905.   my $params = $self->params ($what);
  906.  
  907.   # Probably "static int"
  908.   my ($body, @subs);
  909.   $body = $self->C_constant_return_type($params) . "\n$subname ("
  910.     # Eg "pTHX_ "
  911.     . $self->C_constant_prefix_param_defintion($params)
  912.       # Probably "const char *name"
  913.       . $self->name_param_definition($params);
  914.   # Something like ", STRLEN len"
  915.   $body .= ", " . $self->namelen_param_definition($params)
  916.     unless defined $namelen;
  917.   $body .= $self->C_constant_other_params_defintion($params);
  918.   $body .= ") {\n";
  919.  
  920.   if (defined $namelen) {
  921.     # We are a child subroutine. Print the simple description
  922.     my $comment = 'When generated this function returned values for the list'
  923.       . ' of names given here.  However, subsequent manual editing may have'
  924.         . ' added or removed some.';
  925.     $body .= $self->switch_clause ({indent=>2, comment=>$comment},
  926.                    $namelen, $items, @items);
  927.   } else {
  928.     # We are the top level.
  929.     $body .= "  /* Initially switch on the length of the name.  */\n";
  930.     $body .= $self->dogfood ({package => $package, subname => $subname,
  931.                   default_type => $default_type, what => $what,
  932.                   indent => $indent, breakout => $breakout},
  933.                  @items);
  934.     $body .= '  switch ('.$self->namelen_param().") {\n";
  935.     # Need to group names of the same length
  936.     my @by_length;
  937.     foreach (@items) {
  938.       push @{$by_length[length $_->{name}]}, $_;
  939.     }
  940.     foreach my $i (0 .. $#by_length) {
  941.       next unless $by_length[$i];    # None of this length
  942.       $body .= "  case $i:\n";
  943.       if (@{$by_length[$i]} == 1) {
  944.         my $only_thing = $by_length[$i]->[0];
  945.         if ($only_thing->{utf8}) {
  946.           if ($only_thing->{utf8} eq 'yes') {
  947.             # With utf8 on flag item is passed in element 0
  948.             $body .= $self->match_clause (undef, [$only_thing]);
  949.           } else {
  950.             # With utf8 off flag item is passed in element 1
  951.             $body .= $self->match_clause (undef, [undef, $only_thing]);
  952.           }
  953.         } else {
  954.           $body .= $self->match_clause (undef, $only_thing);
  955.         }
  956.       } elsif (@{$by_length[$i]} < $breakout) {
  957.         $body .= $self->switch_clause ({indent=>4},
  958.                        $i, $items, @{$by_length[$i]});
  959.       } else {
  960.         # Only use the minimal set of parameters actually needed by the types
  961.         # of the names of this length.
  962.         my $what = {};
  963.         foreach (@{$by_length[$i]}) {
  964.           $what->{$_->{type}} = 1;
  965.           $what->{''} = 1 if $_->{utf8};
  966.         }
  967.         $params = $self->params ($what);
  968.         push @subs, $self->C_constant ({package=>$package,
  969.                     subname=>"${subname}_$i",
  970.                     default_type => $default_type,
  971.                     types => $what, indent => $indent,
  972.                     breakout => [$i, $items]},
  973.                        @{$by_length[$i]});
  974.         $body .= "    return ${subname}_$i ("
  975.       # Eg "aTHX_ "
  976.       . $self->C_constant_prefix_param($params)
  977.         # Probably "name"
  978.         . $self->name_param($params);
  979.     $body .= $self->C_constant_other_params($params);
  980.         $body .= ");\n";
  981.       }
  982.       $body .= "    break;\n";
  983.     }
  984.     $body .= "  }\n";
  985.   }
  986.   my $notfound = $self->return_statement_for_notfound();
  987.   $body .= "  $notfound\n" if $notfound;
  988.   $body .= "}\n";
  989.   return (@subs, $body);
  990. }
  991.  
  992. 1;
  993. __END__
  994.  
  995. =back
  996.  
  997. =head1 BUGS
  998.  
  999. Not everything is documented yet.
  1000.  
  1001. Probably others.
  1002.  
  1003. =head1 AUTHOR
  1004.  
  1005. Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
  1006. others
  1007.